home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / compiler / verbose.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  8KB  |  345 lines
  1. {
  2.     $Id: verbose.pas,v 1.2 1998/03/28 23:09:57 florian Exp $
  3.     Copyright (c) 1998 by the FPC development team
  4.  
  5.     This unit handles the verbose management
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23. unit verbose;
  24. interface
  25.  
  26. uses messages;
  27.  
  28. {$define allow_oldstyle}
  29.  
  30. {$IFNDEF EXTERN_MSG}
  31.   {$i msgtxt.inc}
  32. {$ENDIF}
  33.  
  34. {$i msgidx.inc}
  35.  
  36. Const
  37.   MaxErrorCount : longint = 50;
  38. { <$100 can include file and linenr info }
  39.   V_Fatal       = $0;
  40.   V_Error       = $1;
  41.   V_Warning     = $2;
  42.   V_Note        = $4;
  43.   V_Hint        = $8;
  44.   V_Info        = $100;
  45.   V_Linenrs     = $200;
  46.   V_Used        = $400;
  47.   V_Tried       = $800;
  48.   V_Macro       = $1000;
  49.   V_Procedure   = $2000;
  50.   V_Conditional = $4000;
  51.   V_Debug       = $8000;
  52.  
  53.   V_All         = $ffffffff;
  54.   V_Default     = V_Error;
  55.  
  56.   Verbosity     : longint=V_Default;
  57.  
  58. var
  59.   errorcount    : longint;  { number of generated errors }
  60.   msg           : pmessage;
  61.  
  62. procedure LoadMsgFile(const fn:string);
  63. function  SetVerbosity(const s:string):boolean;
  64.  
  65. procedure stop;
  66. procedure comment(l:longint;const s:string);
  67. procedure internalerror(i:longint);
  68. procedure Message(w:tmsgconst);
  69. procedure Message1(w:tmsgconst;const s1:string);
  70. procedure Message2(w:tmsgconst;const s1,s2:string);
  71. procedure Message3(w:tmsgconst;const s1,s2,s3:string);
  72.  
  73. { old calling style }
  74. {$ifdef allow_oldstyle}
  75. var
  76.   exterror      : pchar;
  77. procedure note(w:tmsgconst);
  78. procedure warning(w:tmsgconst);
  79. procedure error(w:tmsgconst);
  80. procedure fatalerror(w:tmsgconst);
  81. {$endif}
  82.  
  83. { Function redirecting for IDE support }
  84. type
  85.   tstopprocedure = procedure;
  86.   tcommentprocedure = procedure(Level:Longint;const s:string);
  87. {old handlers }
  88.   terrorfunction = function(w:tmsgconst) : boolean;
  89.   tinternalerrorfunction = function(i : longint) : boolean;
  90. var
  91. { this procedure is called to stop the compiler                 }
  92. { e.g. this procedure has to restore the state before compiling }
  93.   do_stop : tstopprocedure;
  94.  
  95. { called when writing something to the screen, called with the level }
  96. { of the comment }
  97.   do_comment : tcommentprocedure;
  98.  
  99. { only for compatibility }
  100.   do_note,do_warning,do_error,do_fatalerror : terrorfunction;
  101.   do_internalerror : tinternalerrorfunction;
  102.  
  103.  
  104. implementation
  105. uses globals;
  106.  
  107.  
  108. procedure LoadMsgFile(const fn:string);
  109. begin
  110.   if not (msg=nil) then
  111.    dispose(msg,Done);
  112.   msg:=new(pmessage,InitExtern(fn,ord(endmsgconst)));
  113. end;
  114.  
  115.  
  116. function SetVerbosity(const s:string):boolean;
  117. var
  118.   m : Longint;
  119.   c : Word;
  120. begin
  121.   setverbosity:=false;
  122.   val(s,m,c);
  123.   if (c=0) and (s<>'') then
  124.    verbosity:=m
  125.   else
  126.    begin
  127.      for c:=1 to length(s) do
  128.       case upcase(s[c]) of
  129.       { Special cases }
  130.        'A' : Verbosity:=V_All;
  131.        '0' : Verbosity:=V_Default;
  132.       { Normal cases - do an or }
  133.        'E' : Verbosity:=Verbosity or V_Error;
  134.        'I' : Verbosity:=Verbosity or V_Info;
  135.        'W' : Verbosity:=Verbosity or V_Warning;
  136.        'N' : Verbosity:=Verbosity or V_Note;
  137.        'H' : Verbosity:=Verbosity or V_Hint;
  138.        'L' : Verbosity:=Verbosity or V_Linenrs;
  139.        'U' : Verbosity:=Verbosity or V_Used;
  140.        'T' : Verbosity:=Verbosity or V_Tried;
  141.        'M' : Verbosity:=Verbosity or V_Macro;
  142.        'P' : Verbosity:=Verbosity or V_Procedure;
  143.        'C' : Verbosity:=Verbosity or V_Conditional;
  144.        'D' : Verbosity:=Verbosity or V_Debug;
  145.       end;
  146.    end;
  147.   setverbosity:=true;
  148. end;
  149.  
  150.  
  151.  
  152. procedure stop;
  153. begin
  154. {$ifndef TP}
  155.   do_stop();
  156. {$else}
  157.   do_stop;
  158. {$endif}
  159. end;
  160.  
  161.  
  162. procedure internalerror(i : longint);
  163. begin
  164.   do_internalerror(i);
  165.   stop;
  166. end;
  167.  
  168.  
  169. procedure Comment(l:longint;const s:string);
  170. begin
  171.   do_comment(l,s);
  172. end;
  173.  
  174.  
  175. Procedure Msg2Comment(s:string);
  176. var
  177.   idx,i,v : longint;
  178.   dostop  : boolean;
  179. begin
  180. {Reset}
  181.   dostop:=false;
  182.   v:=0;
  183. {Parse options}
  184.   idx:=pos('_',s);
  185.   if idx=0 then
  186.    v:=V_Default
  187.   else
  188.    if (idx in [1..5]) then
  189.     begin
  190.       for i:=1to idx do
  191.        begin
  192.          case upcase(s[i]) of
  193.           'F' : begin
  194.                   v:=v or V_Fatal;
  195.                   dostop:=true;
  196.                 end;
  197.           'E' : begin
  198.                   v:=v or V_Error;
  199.                   inc(errorcount);
  200.                   dostop:=(errorcount>=maxerrorcount);
  201.                 end;
  202.           'W' : v:=v or V_Warning;
  203.           'N' : v:=v or V_Note;
  204.           'H' : v:=v or V_Hint;
  205.           'I' : v:=v or V_Info;
  206.           'L' : v:=v or V_Linenrs;
  207.           'U' : v:=v or V_Used;
  208.           'T' : v:=v or V_Tried;
  209.           'M' : v:=v or V_Macro;
  210.           'P' : v:=v or V_Procedure;
  211.           'C' : v:=v or V_Conditional;
  212.           'D' : v:=v or V_Debug;
  213.           'S' : dostop:=true;
  214.           '_' : ;
  215.          end;
  216.        end;
  217.     end;
  218.   Delete(s,1,idx);
  219.   Comment(v,s);
  220.   if dostop then
  221.    stop;
  222. end;
  223.  
  224.  
  225. procedure Message(w:tmsgconst);
  226. begin
  227.   Msg2Comment(msg^.Get(ord(w)));
  228. end;
  229.  
  230.  
  231. procedure Message1(w:tmsgconst;const s1:string);
  232. begin
  233.   Msg2Comment(msg^.Get1(ord(w),s1));
  234. end;
  235.  
  236.  
  237. procedure Message2(w:tmsgconst;const s1,s2:string);
  238. begin
  239.   Msg2Comment(msg^.Get2(ord(w),s1,s2));
  240. end;
  241.  
  242.  
  243. procedure Message3(w:tmsgconst;const s1,s2,s3:string);
  244. begin
  245.   Msg2Comment(msg^.Get3(ord(w),s1,s2,s3));
  246. end;
  247.  
  248.  
  249. {*****************************************************************************
  250.                                    Old Style
  251. *****************************************************************************}
  252.  
  253. {$ifdef allow_oldstyle}
  254.  
  255.   procedure warning(w:tmsgconst);
  256.   begin
  257.     if do_warning(w) then
  258.      stop;
  259.   end;
  260.  
  261.  
  262.   procedure note(w:tmsgconst);
  263.   begin
  264.     if do_note(w) then
  265.      stop;
  266.   end;
  267.  
  268.  
  269.   procedure error(w:tmsgconst);
  270.   begin
  271.     inc(errorcount);
  272.     if do_error(w) then
  273.      stop;
  274.   end;
  275.  
  276.  
  277.   procedure fatalerror(w:tmsgconst);
  278.   begin
  279.     do_fatalerror(w);
  280.     stop;
  281.   end;
  282.  
  283. {$endif}
  284.  
  285. begin
  286. {$IFNDEF EXTERN_MSG}
  287.   msg:=new(pmessage,Init(@msgtxt,ord(endmsgconst)));
  288. {$ENDIF}
  289. end.
  290.  
  291. {
  292.   $Log: verbose.pas,v $
  293.   Revision 1.2  1998/03/28 23:09:57  florian
  294.     * secondin bugfix (m68k and i386)
  295.     * overflow checking bugfix (m68k and i386) -- pretty useless in
  296.       secondadd, since everything is done using 32-bit
  297.     * loading pointer to routines hopefully fixed (m68k)
  298.     * flags problem with calls to RTL internal routines fixed (still strcmp
  299.       to fix) (m68k)
  300.     * #ELSE was still incorrect (didn't take care of the previous level)
  301.     * problem with filenames in the command line solved
  302.     * problem with mangledname solved
  303.     * linking name problem solved (was case insensitive)
  304.     * double id problem and potential crash solved
  305.     * stop after first error
  306.     * and=>test problem removed
  307.     * correct read for all float types
  308.     * 2 sigsegv fixes and a cosmetic fix for Internal Error
  309.     * push/pop is now correct optimized (=> mov (%esp),reg)
  310.  
  311.   Revision 1.1.1.1  1998/03/25 11:18:15  root
  312.   * Restored version
  313.  
  314.   Revision 1.17  1998/03/10 16:43:34  peter
  315.     * fixed Fatal error writting
  316.  
  317.   Revision 1.16  1998/03/10 01:17:30  peter
  318.     * all files have the same header
  319.     * messages are fully implemented, EXTDEBUG uses Comment()
  320.     + AG... files for the Assembler generation
  321.  
  322.   Revision 1.15  1998/03/06 00:53:02  peter
  323.     * replaced all old messages from errore.msg, only ExtDebug and some
  324.       Comment() calls are left
  325.     * fixed options.pas
  326.  
  327.   Revision 1.14  1998/03/04 01:35:15  peter
  328.     * messages for unit-handling and assembler/linker
  329.     * the compiler compiles without -dGDB, but doesn't work yet
  330.     + -vh for Hint
  331.  
  332.   Revision 1.13  1998/03/03 16:45:25  peter
  333.     + message support for assembler parsers
  334.  
  335.   Revision 1.12  1998/03/02 16:02:05  peter
  336.     * new style messages for pp.pas
  337.     * cleanup of pp.pas
  338.  
  339.   Revision 1.11  1998/03/02 01:49:40  peter
  340.     * renamed target_DOS to target_GO32V1
  341.     + new verbose system, merged old errors and verbose units into one new
  342.       verbose.pas, so errors.pas is obsolete
  343.  
  344. }
  345.